home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b2tcE.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  5.0 KB  |  241 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b2tcE.c,v 1.4 85/08/22 16:56:55 timo Exp $
  5. */
  6.  
  7. /* process type unification errors */
  8.  
  9. #include "b.h"
  10. #include "b1obj.h"
  11. #include "b2tcP.h"
  12. #include "b2tcE.h"
  13. #include "b2tcU.h"
  14.  
  15. /* 
  16.  * The variables from the users line are inserted in var_list.
  17.  * This is used to produce the right variable names
  18.  * in the error message.
  19.  * Call start_vars() when a new error context is established
  20.  * with the setting of curline.
  21.  */
  22.  
  23. Hidden value var_list;
  24.  
  25. Visible Procedure start_vars() {
  26.     var_list = mk_elt();
  27. }
  28.  
  29. Visible Procedure add_var(tvar) polytype tvar; {
  30.     insert(tvar, &var_list);
  31. }
  32.  
  33. Hidden bool in_vars(t) polytype t; {
  34.     return in(t, var_list);
  35. }
  36.  
  37. Visible Procedure end_vars() {
  38.     release(var_list);
  39. }
  40.  
  41. /* t_repr(u) is used to print polytypes when an error
  42.  * has occurred.
  43.  * Because the errors are printed AFTER unification, the variable 
  44.  * polytypes in question have changed to the error-type.
  45.  * To print the real types in error, the table has to be 
  46.  * saved in reprtable.
  47.  * The routines are called in unify().
  48.  */
  49.  
  50. Hidden value reprtable;
  51. extern value typeof;         /* defined in b2tcP.c */
  52.  
  53. Visible Procedure setreprtable() {
  54.     reprtable = copy(typeof);
  55. }
  56.  
  57. Visible Procedure delreprtable() {
  58.     release(reprtable);
  59. }
  60.  
  61. /* miscellaneous procs */
  62.  
  63. Hidden value conc(v, w) value v, w; {
  64.     value c;
  65.     c = concat(v, w);
  66.     release(v); release(w);
  67.     return c;
  68. }
  69.  
  70. Hidden bool newvar(u) polytype u; {
  71.     value u1;
  72.     char ch;
  73.     u1 = curtail(ident(u), one);
  74.     ch = charval(u1);
  75.     release(u1);
  76.     return (bool) ('0' <= ch && ch <= '9');
  77. }
  78.  
  79. #define Known(tu) (!t_is_var(kind(tu)) && !t_is_error(kind(tu)))
  80.  
  81. Hidden bool knowntype(u) polytype u; {
  82.     value tu;
  83.     tu = u;
  84.     while (t_is_var(kind(tu)) && in_keys(ident(tu), reprtable))
  85.         tu = *adrassoc(reprtable, ident(tu));
  86.     return Known(tu);
  87. }
  88.  
  89. Hidden bool outervar = Yes;
  90.  
  91. Hidden value t_repr(u) polytype u; {
  92.     typekind u_kind;
  93.     value c;
  94.     
  95.     u_kind = kind(u);
  96.     if (t_is_number(u_kind)) {
  97.         return mk_text("0");
  98.     }
  99.     else if (t_is_text(u_kind)) {
  100.         return mk_text("''");
  101.     }
  102.     else if (t_is_tn(u_kind)) {
  103.         return mk_text("'' or 0");
  104.     }
  105.     else if (t_is_compound(u_kind)) {
  106.         intlet k, len = nsubtypes(u);
  107.         c = mk_text("(");
  108.         for (k = 0; k < len - 1; k++) {
  109.             c = conc(c, t_repr(subtype(u, k)));
  110.             c = conc(c, mk_text(", "));
  111.         }
  112.         c = conc(c, t_repr(subtype(u, k)));
  113.         return conc(c, mk_text(")"));
  114.     }
  115.     else if (t_is_error(u_kind)) {
  116.         return mk_text(" ");
  117.     }
  118.     else if (t_is_var(u_kind)) {
  119.         value tu;
  120.         tu = u;
  121.         while (t_is_var(kind(tu)) && in_keys(ident(tu), reprtable))
  122.             tu = *adrassoc(reprtable, ident(tu));
  123.         if (in_vars(u)) {
  124.             if (Known(tu)) {
  125.                 if (outervar) {
  126.                     outervar = No;
  127.                     c = conc(t_repr(tu), mk_text(" for "));
  128.                     outervar = Yes;
  129.                     return conc(c, copy(ident(u)));
  130.                 }
  131.                 else
  132.                     return t_repr(tu);
  133.             }
  134.             else {
  135.                 return copy(ident(u));
  136.             }
  137.         }
  138.         else if (Known(tu))
  139.             return t_repr(tu);
  140.         else if (newvar(u))
  141.             return mk_text(" ");
  142.         else
  143.             return copy(ident(u));
  144.     }
  145.     else if (t_is_table(u_kind)) {
  146.         if (knowntype(keytype(u))) {
  147.             if (knowntype(asctype(u))) {
  148.                 c = conc(mk_text("{["),
  149.                     t_repr(keytype(u)));
  150.                 c = conc(c, mk_text("]:"));
  151.                 c = conc(c, t_repr(asctype(u)));
  152.                 return conc(c, mk_text("}"));
  153.             }
  154.             else {
  155.                 c = conc(mk_text("table with type "),
  156.                     t_repr(keytype(u)));
  157.                 return conc(c, mk_text(" keys"));
  158.             }
  159.         }
  160.         else if (knowntype(asctype(u))) {
  161.             c = conc(mk_text("table with type "),
  162.                 t_repr(asctype(u)));
  163.             return conc(c, mk_text(" associates"));
  164.         }
  165.         else {
  166.             return mk_text("table");
  167.         }
  168.     }
  169.     else if (t_is_list(u_kind)) {
  170.         if (knowntype(asctype(u))) {
  171.             c = conc(mk_text("{"), t_repr(asctype(u)));
  172.             return conc(c, mk_text("}"));
  173.         }
  174.         else {
  175.             return mk_text("list");
  176.         }
  177.     }
  178.     else if (t_is_lt(u_kind)) {
  179.         if (knowntype(asctype(u)))
  180.             return conc(mk_text("list or table of "),
  181.                     t_repr(asctype(u)));
  182.         else
  183.             return mk_text("{}");
  184.     }
  185.     else if (t_is_tlt(u_kind)) {
  186.         if (knowntype(asctype(u)))
  187.             return conc(mk_text("text list or table of "),
  188.                     t_repr(asctype(u)));
  189.         else
  190.             return mk_text("text list or table");
  191.     }
  192.     else {
  193.         syserr(MESS(4300, "unknown polytype in t_repr"));
  194.         return mk_text("***");
  195.     }
  196. }
  197.  
  198. /* now, the real error messages */
  199.  
  200. Visible Procedure badtyperr(a, b) polytype a, b; {
  201.     value t;
  202.  
  203. /*error4("incompatible types: ", ta, ", and ", tb); */
  204.  
  205.     t = conc(t_repr(a), mk_text(" and "));
  206.     t = conc(t, t_repr(b));
  207.     error2(MESS(4301, "incompatible types "), t);
  208.     release(t);
  209. }
  210.  
  211. Visible Procedure cyctyperr(a) polytype a; {
  212.     value vcyc;
  213.     
  214.     vcyc = Vnil;
  215.     if (in_vars(a))
  216.         vcyc = ident(a);
  217.     else {
  218.         value n, m, nvars, v;
  219.         n = copy(one);
  220.         nvars = size(var_list);
  221.         while (compare(n, nvars) <= 0) {
  222.             v = th_of(n, var_list);
  223.             if (equal_vars(v, a) || contains(v, a)) {
  224.                 vcyc = ident(v);
  225.                 break;
  226.             }
  227.             m = n;
  228.             n = sum(n, one);
  229.             release(m); release(v);
  230.         }
  231.         release(n); release(nvars);
  232.         if (vcyc EQ Vnil) {
  233.             error2(MESS(4302, "unknown cyclic type"), ident(a));
  234.             syserr(MESS(4303, "unknown cyclic type"));
  235.             return;
  236.         }
  237.     }
  238.     error3(MESS(4304, "(sub)type of "), vcyc,
  239.         MESS(4305, " contains itself"));
  240. }
  241.